perm filename LISS.F4[JC,MUS]1 blob
sn#007319 filedate 1972-07-16 generic text, type T, neo UTF8
00100 SUBROUTINE SPACE4(AMP,RAMP,DOP,CHNA,CHNB,CHNC,CHND,ARRAY)
00200 DIMENSION AMP(512),RAMP(512),DOP(512),
00300 1 CHNA(512),CHNB(512),CHNC(512),CHND(512)
00400 DIMENSION F(7),G(3)
00500 DIMENSION ARRAY(2,600),B(4),C(3),D(4),E(7)
00600 DIMENSION ST(50),SU(350)
00700 DATA (B(I),I=1,3)/'A TO B IN FT.'/
00800 DATA (C(I),I=1,3)/'LISS=1,LINE=2'/
00900 DATA (D(I),I=1,3)/'0=FIN,1=REDEF'/
01000 DATA (E(I),I=1,6)/'SEE AMP=1,DOP=2,STER1=3 OR 0'/
01100 DATA (F(I),I=1,6)/'X,Y,RAD OR X1,Y1,X2,Y2,X3,Y3'/
01200 DATA (G(I),I=1,2)/'CYCL TM='/
01300 CALL TYPLOC(-300,-512)
01400 101 CONTINUE
01450 C CALL CLEAR
01500 CALL DPYSET(1,ST,50)
01600 CALL DPYBRT(1)
01700 CALL AIVECT(0,0)
01800 CALL HYDPOG(1)
01900 IF(KT1.EQ.1)KT1=513
02000 IY=100
02100 DO 11 I=1,2
02200 CALL ALINE(-100,IY,100,IY)
02300 11 IY=-IY
02400 IX=100
02500 DO 12 I=1,2
02600 CALL ALINE(IX,-100,IX,100)
02700 12 IX=-IX
02800 CALL ALINE(0,0,0,100)
02900 CALL DPYOUT(1)
03000 CC SPACE DEFINITION FINISHED
03100 CALL MESS(B)
03200 CALL RDNUM(DIS)
03300 DELTA=DIS/100.0
03400 CALL MESS(C)
03500 CALL RDNUM(XNUM)
03600 IF(XNUM.EQ.0.0)GO TO 20
03700 L=XNUM
03800 CALL DPYSET(2,SU,350)
03900 CALL DPYBRT(6)
04000 CALL AIVECT(0,0)
04100 CALL MESS(F)
04200 GO TO (1,2,2),L
04300 1 CALL RDNUM(XCO)
04400 CALL RDNUM(YCO)
04500 CALL RDNUM(RADIUS)
04600 RADNS=(2.0*3.1415927)/512.0
04700 CRADNS=RADNS
04800 IL=1
04900 36 CONTINUE
05000 SINR=SIN(CRADNS)
05100 COSR=COS(CRADNS)
05200 CRADNS=CRADNS+RADNS
05300 ARRAY(1,IL)=SINR*RADIUS+XCO
05400 ARRAY(2,IL)=COSR*RADIUS+YCO
05500 GO TO 520
05600 2 CALL RDNUM(XCO1)
05700 CALL RDNUM(YCO1)
05800 CALL RDNUM(FREQX)
05900 CALL RDNUM(PHASX)
06000 CALL RDNUM(FREQY)
06100 CALL RDNUM(PHASY)
06200 CALL RDNUM(FREQ2X)
06210 CALL RDNUM(PHAS2X)
06220 CALL RDNUM(FREQ2Y)
06230 CALL RDNUM(PHAS2Y)
06300 CALL RDNUM(DIA)
06310 CALL RDNUM(DIA2)
06400 IF(L.EQ.3)GOTO 3
06500 XINC=(FREQX*360.)/512.
06510 XINC2=(FREQ2X*360.)/512.
06600 XK=-XINC+PHASX
06610 XK2=-XINC2+PHAS2X
06700 YINC=(FREQY*360.)/512.
06710 YINC2=(FREQ2Y*360.)/512.
06800 YK=-YINC+PHASY
06810 YK2=-YINC2+PHAS2Y
06900 IL=1
07000 37 CONTINUE
07100 XX=XK+XINC
07110 XX2=XK2+XINC2
07200 IF(XX.GE.360.)XX=XX-360.
07210 IF(XX2.GE.360.)XX2=XX2-360.
07300 XK=XX
07310 XK2=XX2
07400 YY=YK+YINC
07410 YY2=YK2+YINC2
07500 IF(YY.GE.360.)YY=YY-360.
07510 IF(YY2.GE.360.)YY2=YY2-360.
07600 YK=YY
07610 YK2=YY2
07700 ARRAY(1,IL)=XCO1+SIND(XX)*DIA+(SIND(XX2)*DIA2)
07800 ARRAY(2,IL)=YCO1+SIND(YY)*DIA+(SIND(YY2)*DIA2)
07900 GO TO 520
08000 3 CALL RDNUM(XCO3)
08100 CALL RDNUM(YCO3)
08200 XDIF1=XCO2-XCO1
08300 XDIF2=XCO3-XCO2
08400 YDIF1=YCO2-YCO1
08500 YDIF2=YCO3-YCO2
08600 XCO4=XCO2+XDIF2-XDIF1
08700 YCO4=YCO2+YDIF2-YDIF1
08800 XCOI1=XDIF1/128.
08900 XCOI2=XDIF2/128.
09000 YCOI1=YDIF1/128.
09100 YCOI2=YDIF2/128.
09200 C XCO1=XCO1-XCOI1
09300 C YCO1=YCO1-YCOI1
09400 IL=1
09500 32 IF(IL.GT.128)GO TO 33
09600 ARRAY(1,IL)=XCO1+XCOI1
09700 ARRAY(2,IL)=YCO1+YCOI1
09800 XCO1=ARRAY(1,IL)
09900 YCO1=ARRAY(2,IL)
10000 GO TO 520
10100 33 IF(IL.GT.256.)GO TO 34
10200 ARRAY(1,IL)=XCO2+XCOI2
10300 ARRAY(2,IL)=YCO2+YCOI2
10400 XCO2=ARRAY(1,IL)
10500 YCO2=ARRAY(2,IL)
10600 GO TO 520
10700 34 IF(IL.GT.384)GO TO 35
10800 ARRAY(1,IL)=XCO3-XCOI1
10900 ARRAY(2,IL)=YCO3-YCOI1
11000 XCO3=ARRAY(1,IL)
11100 YCO3=ARRAY(2,IL)
11200 GO TO 520
11300 35 ARRAY(1,IL)=XCO4-XCOI2
11400 ARRAY(2,IL)=YCO4-YCOI2
11500 XCO4=ARRAY(1,IL)
11600 YCO4=ARRAY(2,IL)
11700 520 NEWX=ARRAY(1,IL)
11800 NEWY=ARRAY(2,IL)
11900 IF(IL.GT.1)GO TO 503
12000 CALL AIVECT(NEWX,NEWY)
12100 GO TO 504
12200 503 CALL SVECT(NEWX-IOLDX,NEWY-IOLDY)
12300 504 IOLDX=NEWX
12400 IOLDY=NEWY
12500 CALL DPYOUT(2)
12600 IL=IL+1
12700 IF(IL.GT.512)GO TO 500
12800 GO TO (36,37,32),L
12900 500 CONTINUE
13000 M=512
13100 CALL MESS(G)
13200 CALL RDNUM(SPD1)
13300 SPD1=60.0/((1.0/SPD1)*512.0)
13400 GO TO 501
13500 20 SPD1=SPD
13600 C CALL POS(ARRAY,600,M,SPD1)
13700 501 X=M-1
13800 AI=X/512.0
13900 BI=2.0
14000 S=60.0/SPD1
14100 R=SQRT(ARRAY(1,1)**2+ARRAY(2,1)**2)
14200 DO 100 J=1,512
14300 I=BI
14400 X=ARRAY(1,I)
14500 Y=ARRAY(2,I)
14600 BI=BI+AI
14700 R1=SQRT(X**2+Y**2)
14800 AMP(J)=DIS/(R1*DELTA)
14900 RAMP(J)=ALOG(DIS)/ALOG(R1*DELTA)
14950 IF(RAMP(J).GT.1.)RAMP(J)=1.
15000 CONTINUE
15100 VR=S*DELTA*(R1-R)
15200 XJ=J
15300 IF((R1.EQ.R).AND.(XJ.GT.1.0))GO TO 31
15400 DOP(J)=1180.0/(1180.0+VR)
15500 GO TO 21
15600 31 DOP(J)=DOP(J-1)
15700 21 R=R1
15800 CONTINUE
15900 AX=ABS(X)
16000 AY=ABS(Y)
16100 PI=3.1416
16200 ANGLE=AMOD(ATAN2(Y,X)+6.2832,6.2832)
16300 PI2=PI/2.0
16400 IF((AX.LE.AY).AND.(Y.GT.0.0))GO TO 2000
16500 IF((AX.GT.AY).AND.(X.GT.0.0))GO TO 2001
16600 IF((AX.LE.AY).AND.(Y.LT.0.0))GO TO 2002
16700 CHN=ANGLE-(3.*PI)/4.
16800 CHNB(J)=1.-CHN/PI2
16900 CHNC(J)=CHN/PI2
17000 CHNA(J)=0.0
17100 CHND(J)=0.0
17200 GO TO 100
17300 2000 CHN=ANGLE-PI/4.
17400 CHNA(J)=1.-CHN/PI2
17500 CHNB(J)=CHN/PI2
17600 CHNC(J)=0.0
17700 CHND(J)=0.0
17800 GO TO 100
17900 2001 CHN=ANGLE-(7.*PI)/4.
18000 IF(ANGLE.LT.PI/4.)CHN=ANGLE+PI/4.
18100 CHND(J)=1.-CHN/PI2
18200 CHNA(J)=CHN/PI2
18300 CHNB(J)=0.0
18400 CHNC(J)=0.0
18500 GO TO 100
18600 2002 CHN=ANGLE-(5.*PI)/4.
18700 CHNC(J)=1.-CHN/PI2
18800 CHND(J)=CHN/PI2
18900 CHNA(J)=0.0
19000 CHNB(J)=0.0
19100 100 CONTINUE
19200 DO 402 JK=1,512
19300 CHNA(JK)=SQRT(CHNA(JK))
19400 CHNB(JK)=SQRT(CHNB(JK))
19500 CHNC(JK)=SQRT(CHNC(JK))
19600 CHND(JK)=SQRT(CHND(JK))
19700 402 CONTINUE
19800 CALL INTERP(AMP)
19900 CALL INTERP(RAMP)
20000 CALL INTERP(DOP)
20100 C CALL INTERP(CHNA)
20200 C CALL INTERP(CHNB)
20300 C CALL INTERP(CHNC)
20400 C CALL INTERP(CHND)
20500 801 CONTINUE
20600 GO TO 937
20700 99 CONTINUE
20800 937 CALL MESS(E)
20900 CALL RDNUM(X)
21000 L=X
21100 IF(L.EQ.0)GO TO 200
21200 IF(L.GT.3)GO TO 937
21300 CALL HYDPOG(1)
21400 CALL HYDPOG(2)
21500 C CALL CLEAR
21600 CALL DPYSET(1,ST,50)
21700 CALL DPYBRT(1)
21800 CALL AIVECT(0,0)
21900 IF(L.EQ.3)GO TO 203
22000 CALL ALINE(-264,0,256,0)
22100 CALL ALINE(-256,-256,-256,256)
22200 CALL DPYOUT(1)
22300 CALL DPYSET(2,SU,350)
22400 CALL DPYBRT(6)
22500 CALL AIVECT(0,0)
22600 GO TO(201,202),L
22700 201 IY=AMP(1)*256.
22800 CALL AIVECT(-256,IY)
22900 DO 301 I=2,512
23000 IY2=AMP(I)*256.0
23100 CALL SVECT(1,IY2-IY)
23200 IY=IY2
23300 301 CALL DPYOUT(2)
23400 GO TO 99
23500 202 IY=DOP(1)*256.-256.
23600 CALL AIVECT(-256,IY)
23700 DO 302 I=2,512
23800 IY2=DOP(I)*256.0-256.
23900 CALL SVECT(1,IY2-IY)
24000 IY=IY2
24100 302 CALL DPYOUT(2)
24200 GO TO 99
24300 203 CONTINUE
24350 C CALL CLEAR
24400 DO 300 J=-375,375,250
24500 CALL AIVECT(0,J)
24600 CALL RVECT(256,0)
24700 CALL RIVECT(-256,-125)
24800 CALL RVECT(0,250)
24900 300 CALL DPYOUT(1)
25000 CALL DPYSET(2,SU,350)
25100 CALL DPYBRT(6)
25200 CALL AIVECT(0,0)
25300 IY=375
25400 CALL DRAW(CHNA,IY)
25500 IY=125
25600 CALL DRAW(CHNB,IY)
25700 IY=-125
25800 CALL DRAW(CHNC,IY)
25900 IY=-375
26000 CALL DRAW(CHND,IY)
26100 GO TO 99
26200 200 CALL MESS(D)
26300 CALL RDNUM(X)
26400 IF(X.EQ.0.0)GO TO 307
26500 CALL HYDPOG(2)
26600 GO TO 101
26700 307 CONTINUE
26750 C CALL CLEAR
26800 CALL DPYCLR
26900 RETURN
27000 END
27100 CC******WAVE DRAWER**********************************************
27200 SUBROUTINE DRAW(FUNC,ICT)
27300 DIMENSION FUNC(512)
27400 CALL AIVECT(0,ICT)
27500 DO 100 I=1,512,4
27600 IY2=FUNC(I)*125.
27700 IF(I.GT.1)GO TO 10
27800 CALL RIVECT(0,IY2)
27900 GO TO 101
28000 10 CALL SVECT(2,IY2-IY)
28100 101 IY=IY2
28200 100 CALL DPYOUT(2)
28300 RETURN
28400 END
28500 CC******WAVE SMOOTHER********************************************
28600 SUBROUTINE INTERP(CFUNC)
28700 DIMENSION CFUNC(512)
28800 JT=0
28900 DO 601 KT=2,512
29000 IF(CFUNC(KT-1).NE.CFUNC(KT))GO TO 600
29100 IF(JT.EQ.0)JT=KT-1
29200 GO TO 601
29300 600 IF(JT.EQ.0)GO TO 601
29400 DIFF=CFUNC(KT)-CFUNC(JT)
29500 DIV=KT-JT
29600 ANS=DIFF/DIV
29700 DO 602 LM=JT+1,KT-1
29800 602 CFUNC(LM)=CFUNC(LM-1)+ANS
29900 JT=0
30000 601 CONTINUE
30100 RETURN
30200 END